;; ===========================
;; VOCABULARY DATA ABSTRACTION
;; ===========================
(library (vocabulary-data)
  (export
   read-vocabulary
   save-vocabulary
   ;; attribute parts
   get:attribute/key
   get:attribute/value
   ;; word parts
   get:entry/translation-data
   get:entry/metadata
   get:entry/attribute
   entry:set-learned-status
   entries:set-learned-status!
   ;; vocabulary parts
   get:vocabulary/metadata
   get:vocabulary/entries
   get:vocabulary/nth-entry
   vocabulary/entries:length
   ;; member functions
   metadata-member
   translation-data-member
   entry-member
   entry-id-equal?
   search-in-vocabulary-entry-attributes
   vocabulary-search
   vocabulary-filter
   vocabulary-get-attribute-names
   vocabulary-get-translation-data-attribute-names
   vocabulary-get-metadata-attribute-names
   ;; vocabulary operations
   vocabulary-union
   vocabulary-merge
   ;; display
   display-voc-entry
   default-display-attributes)
  (import (except (rnrs base) map vector-map)
          (only (guile)
                lambda* λ
                ;; ports
                current-output-port
                simple-format
                pk
                display
                string-join
                newline
                when)
          ;; GNU Guile batteries
          (ice-9 exceptions)
          (ice-9 match)
          ;; custom libraries
          (list-procs)
          (alist-procs)
          (vector-procs)
          (print-utils)
          (bool-utils)
          (json-reader)
          (json-writer)
          (search)
          ;; SRFIs
          ;; SRFI 1 - list procs
          (srfi srfi-1)
          ;; SRFI 43 - vector procs
          (srfi srfi-43)
          ;; SRFI 69 - hash tables
          (srfi srfi-69)))


(define rest
  (λ (lst)
    (cdr lst)))

;; ======================
;; VOCABULARY PERSISTENCE
;; ======================

(define add-vocabulary-entry-ids
  (λ (vocabulary)
    "Add an id to the metadata of each vocabulary entry."

    (define add-entry-id
      (λ (entry id)
        "Add an id to the metadata of an entry."
        `(("metadata" . ,(alist-cons "id" id (get:entry/metadata entry)))
          ("translation-data" . ,(get:entry/translation-data entry)))))

    (let* ([metadata (get:vocabulary/metadata vocabulary)]
           [entries (get:vocabulary/entries vocabulary)]
           [entries-with-id
            (vector-map (λ (index entry) (add-entry-id entry index))
                        entries)])
      `(("metadata" . ,metadata)
        ("words" . ,entries-with-id)))))


(define remove-vocabulary-entry-ids
  (λ (vocabulary)
    "Remove the id of each entry in the vocabulary."

    (define remove-entry-id
      (λ (entry)
        "Remove the id of a vocabulary entry."
        `(("metadata" . ,(alist-delete "id" (get:entry/metadata entry) equal?))
          ("translation-data" . ,(get:entry/translation-data entry)))))

    (let* ([metadata (get:vocabulary/metadata vocabulary)]
           [entries-with-id (get:vocabulary/entries vocabulary)]
           [entries
            (vector-map (λ (index entry) (remove-entry-id entry))
                        entries-with-id)])
      `(("metadata" . ,metadata)
        ("words" . ,entries)))))


(define read-vocabulary
  (λ (file-path)
    (add-vocabulary-entry-ids
      (get-json-from-file file-path))))


(define save-vocabulary
  (λ (file-path vocabulary)
    (put-json-to-file file-path
                      (remove-vocabulary-entry-ids vocabulary)
                      #:pretty #t)))

;; =======
;; GETTERS
;; =======

(define get:vocabulary/metadata
  (λ (vocabulary)
    "Return the metadata of the given VOCABULARY."
    (alist-refs vocabulary '("metadata"))))


(define get:vocabulary/entries
  (λ (vocabulary)
    "Return the words of the given VOCABULARY."
    (alist-refs vocabulary '("words"))))


(define get:attribute/key
  (λ (attribute)
    (alist-item-key attribute)))


(define get:attribute/value
  (λ (attribute)
    (alist-item-value attribute)))


(define get:entry/translation-data
  (λ (entry)
    "Retrieve translation data from ENTRY."
    (rest (alist-find-item-by-key "translation-data" entry))))


(define get:entry/metadata
  (λ (entry)
    "Retrieve metadata from ENTRY."
    (rest (alist-find-item-by-key "metadata" entry))))


(define get:vocabulary/nth-entry
  (λ (vocabulary n)
    (vector-ref (get:vocabulary/entries vocabulary) n)))


(define get:entry/attribute
  (λ (voc-entry attr-location)
    "Get the attribute of the given ATTR-LOCATION from the
given VOC-ENTRY."
    (alist-refs voc-entry attr-location)))

;; =====
;; OTHER
;; =====

(define metadata-member
  (lambda* (seeked entry #:key (equal-test equal?))
    "Check, whether SEEKED is a value in the metadata of ENTRY."
    (let ([metadata (get:entry/metadata entry)])
      (alist-find-item-by-value seeked metadata #:equal-test equal-test))))


(define translation-data-member
  (lambda* (seeked entry #:key (equal-test equal?))
    "Check, whether SEEKED is a value in the translation data of ENTRY."
    (let ([translation-data (get:entry/translation-data entry)])
      (alist-find-item-by-value seeked translation-data #:equal-test equal-test))))


(define entry-member
  (lambda* (seeked entry #:key (equal-test equal?))
    "Seek SEEKED in the translation data of a VOCABULARY entry."
    (or (metadata-member seeked entry #:equal-test equal-test)
        (translation-data-member seeked entry #:equal-test equal-test))))


(define entry-id-equal?
  (λ (entry1 entry2)
    "Check if 2 entries have the same id."
    (equal? (alist-refs (get:entry/metadata entry1)
                        '("id"))
            (alist-refs (get:entry/metadata entry2)
                        '("id")))))


(define vocabulary-get-attribute-names
  (λ (vocabulary)
    "Get the words contained in the vocabulary."
    (let ([first-entry (vector-ref (get:vocabulary/entries vocabulary) 0)])
      (let ([metadata (get:entry/metadata first-entry)]
            [translation-data (get:entry/translation-data first-entry)])
        (append (map (λ (elem) (alist-item-key elem)) metadata)
                (map (λ (elem) (alist-item-key elem)) translation-data))))))


(define vocabulary-get-metadata-attribute-names
  (λ (vocabulary)
    "Get the words contained in the vocabulary."
    (let ([first-entry (vector-ref (get:vocabulary/entries vocabulary) 0)])
      (map (λ (elem) (alist-item-key elem))
           (get:entry/metadata first-entry)))))


(define vocabulary-get-translation-data-attribute-names
  (λ (vocabulary)
    "Get the words contained in the vocabulary."
    (let ([first-entry (vector-ref (get:vocabulary/entries vocabulary) 0)])
      (map (λ (elem) (alist-item-key elem))
           (get:entry/translation-data first-entry)))))


(define search-in-vocabulary-entry-attributes
  (lambda* (attributes
            search-val
            #:key
            (equal-test? (make-general-comparator))
            (attribute-test? equal?))
    "Search for the given SEARCH-VAL in the specified
ATTRIBUTES of the given VOC-ENTRY."
    (cond
     ;; If there are no more attributes to search in and #t
     ;; was not yet returned, then it means there is no
     ;; attribute, of which the value is considered to be
     ;; equal, according to the given equal-test? function.
     [(null? attributes) #f]
     [else
      ;; Look at the next attribute.
      (let ([current-attr (first attributes)])
        ;; Check, if the attribute is supposed to be even
        ;; considered, according to the given
        ;; attribute-test? function.
        (cond
         [(attribute-test? current-attr)
          ;; Check if the value of the attribute is
          ;; considered to be equal by the equal-test?
          ;; function.
          (cond
           ;; If the value is considered equal, return #t.
           [(equal-test? (get:attribute/value current-attr)
                         search-val)
            #t]
           ;; Otherwise look at the next attribute.
           [else
            (search-in-vocabulary-entry-attributes (rest attributes)
                                                   search-val)])]
         ;; If the attribute is not supposed to be
         ;; considered, recur and look at the next
         ;; attribute.
         [else
          (search-in-vocabulary-entry-attributes (rest attributes)
                                                 search-val)]))])))


(define vocabulary-search
  (lambda* (vocabulary
            search-term
            #:key
            (negated #f)
            (equal-test? (make-general-comparator))
            (attribute-test? equal?))
    "Search the vocabulary for the given search term using
the given equality test to check, whether an attribute
contains the search term and using the given attribute test
to determin, whether or not to check an attribute."
    (get:vocabulary/entries
     (vocabulary-filter (λ (voc-entry)
                          (xor (or (search-in-vocabulary-entry-attributes
                                    (get:entry/metadata voc-entry)
                                    search-term
                                    #:equal-test? equal-test?
                                    #:attribute-test? attribute-test?)
                                   (search-in-vocabulary-entry-attributes
                                    (get:entry/translation-data voc-entry)
                                    search-term
                                    #:equal-test? equal-test?
                                    #:attribute-test? attribute-test?))
                               negated))
                        vocabulary))))


(define vocabulary-filter
  (λ (pred vocabulary)
    "Filter the given VOCABULARY using the given PRED
predicate."
    (let ([filtered-vocabulary-entries
           (vector-filter pred (get:vocabulary/entries vocabulary))])
      (let ([metadata (get:vocabulary/metadata vocabulary)])
        `(("metadata" . ,metadata)
          ("words" . ,filtered-vocabulary-entries))))))


(define default-display-attributes
  (alist-refs (get-json-from-file "settings.json")
              '("default" "displayed-attributes")))


(define display-entry-attribute
  (lambda* (attribute
            #:key
            (output-port (current-output-port))
            (separator " | "))
    "Display a single vocabulary entry attribute."
    (let ([attr-name (alist-item-key attribute)]
          [attr-val (alist-item-value attribute)])
      (cond
       [(vector? attr-val)
        (simple-format output-port
                       "~a: ~a\n"
                       attr-name
                       (string-join (vector->list attr-val) separator))]
       [else
        (simple-format output-port
                       "~a: ~a\n"
                       attr-name
                       attr-val)]))))

(define display-voc-entry
  (lambda* (entry
            #:key
            (output-port (current-output-port))
            (meta-attr-visibility-pred
             (λ (attr-name)
               (vector-contains default-display-attributes attr-name)))
            (translation-attr-visibility-pred
             (λ (attr-name)
               (vector-contains default-display-attributes attr-name)))
            (start "") (separator "") (end "")
            (attribute-value-separator " | "))
    (display start output-port)
    ;; render metadata
    (let ([meta (get:entry/metadata entry)])
      (for-each (λ (meta-attr)
                  (when (meta-attr-visibility-pred (alist-item-key meta-attr))
                    (display-entry-attribute meta-attr
                                             #:output-port output-port
                                             #:separator attribute-value-separator)))
                meta))
    ;; render translation data
    (let ([translation-data (get:entry/translation-data entry)])
      (for-each (λ (translation-attr)
                  (when (translation-attr-visibility-pred
                         (alist-item-key translation-attr))
                    (display-entry-attribute translation-attr
                                             #:output-port output-port
                                             #:separator attribute-value-separator)))
                translation-data))
    (display separator output-port)
    (display end output-port)))


(define vocabulary-union
  (λ (vocs1 vocs2)
    "Set union vocabularies."
    (let ([meta1 (alist-item-value (alist-find-item-by-key "metadata" vocs1))]
          [words1 (alist-item-value (alist-find-item-by-key "words" vocs1))]
          [words2 (alist-item-value (alist-find-item-by-key "words" vocs2))])
      `(("metadata" . ,meta1)
        ("words" . ,(vector-union words1 words2))))))


(define vocabulary-merge
  (lambda* (vocabulary-left
            vocabulary-right
            #:key
            (metadata-merge
             (λ (left right)
               right))
            (translation-data-merge
             (λ (left right)
               right)))
    "Merge 2 vocabularies, entry by entry, preferring the
entry which SELECTER selects."
    (let ([entries-left (get:vocabulary/entries vocabulary-left)]
          [entries-right (get:vocabulary/entries vocabulary-right)])
      `(("metadata" .
         ,(metadata-merge (get:vocabulary/metadata vocabulary-left)
                          (get:vocabulary/metadata vocabulary-right)))
        ("words" .
         ,(vector-update-elements
           entries-left
           entries-right
           #:should-update? entry-id-equal?
           #:update-item
           (λ (left-entry right-entry)
             (simple-format (current-output-port) "~a\n" "updated:")
             (print-limited
              `(("metadata" .
                 ,(metadata-merge (get:entry/metadata left-entry)
                                  (get:entry/metadata right-entry)))
                ("translation-data" .
                 ,(translation-data-merge (get:entry/translation-data left-entry)
                                          (get:entry/translation-data right-entry)))))
             ;; NOTE: One could check for equality first,
             ;; before merging, but in this case, the
             ;; equality check for the whole alist might
             ;; consume an equally long time and we only
             ;; replace the left entry with the right
             ;; entry. This means, that it would probably
             ;; consume more time in total, to first check
             ;; for equality and then do the merge
             ;; conditionally.
             `(("metadata" .
                ,(metadata-merge (get:entry/metadata left-entry)
                                 (get:entry/metadata right-entry)))
               ("translation-data" .
                ,(translation-data-merge (get:entry/translation-data left-entry)
                                         (get:entry/translation-data right-entry)))))))))))


(define vocabulary/entries:length
  (λ (vocabulary)
    (vector-length (get:vocabulary/entries vocabulary))))


(define entry:set-learned-status
  (λ (voc-entry learned-status)
    "Sets the learned attribute of a vocabulary entry
functionally."
    (match voc-entry
      [(("metadata" . metadata)
        ("translation-data" . translation-data))
       `(("metadata" . ,(alist-set metadata "learned" learned-status))
         ("translation-data" . ,translation-data))]
      [(("translation-data" . translation-data)
        ("metadata" . metadata))
       `(("metadata" . ,(alist-set metadata "learned" learned-status))
         ("translation-data" . ,translation-data))]
      [else
       (raise-exception
        (make-exception
         (make-non-continuable-error)
         (make-exception-with-message "vocabulary entry has wrong structure")
         (make-exception-with-irritants voc-entry)
         (make-exception-with-origin 'entry:mark-learned)))])))


(define entries:set-learned-status!
  (λ (voc-entries indices learned-status)
    "Set the learned status for the entries in the given
VOC-ENTRIES corresponding to the INDICES as specified in
LEARNED-STATUS.

ASSUMPTION: This procedure assumes, that indices and
learned-status are of equal length or learned-status is
longer."
    (let loop ([remaining-indices indices]
               [remaining-learned-status learned-status])
      (cond
       [(null? remaining-indices) 'done]
       [else
        (let ([index (car remaining-indices)]
              [learned (car remaining-learned-status)])
          (vector-set! voc-entries
                       index
                       (entry:set-learned-status (vector-ref voc-entries index)
                                                 learned)))
        (loop (rest remaining-indices)
              (rest learned-status))]))))
